home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
tpb4_src.zip
/
SYSOP2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-09-14
|
19KB
|
584 lines
{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault
Last modified :: 9-5-88 12:35 pm
}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I+} {I/O checking on}
{$N-} {No numeric coprocessor}
Unit Sysop2;
Interface
Uses
TPCrt, Dos, Globals, TAccess, Core1,
Core2, TPDos, TPSTRING, Dirs, MsgMisc,
Sysop1, Sort;
procedure sys_dir;
procedure purge_files;
{==========================================================================}
Implementation
procedure sys_dir;
{ Create system directory file }
var
TmpDrv, KepDrv : Str3;
This : SectPtr;
DestName : DosFileName;
t : tad_array;
KepReq : Str10;
Str : StrTAD;
TmpName,
KepName : StrPr;
not_found : Integer;
procedure write_list;
{ write list of files in current section }
var
Str : string;
i : LongInt;
Dirspec : StrPr;
key, SearchKey : DosFileName;
need_sort : Boolean;
procedure write_rec;
begin
with nwin_rec do
begin
not_found := 0;
Str := pad(name, 15);
Write(sort_file, Str);
if CreditType = Points then
WriteLn(sort_file, ' Cost: ', PointValue, ' Points')
else
WriteLn(sort_file);
WriteLn(sort_file, ' ', descr);
end;
end;
begin
abort := False;
Dirspec := SetName;
WriteLn(dir_file);
WriteLn(dir_file);
WriteLn(dir_file, 'File area: ', SectReq, ' (', This^.SectDesc, ')');
WriteLn(dir_file);
Assign(sort_file, 'SORT.TMP');
Rewrite(sort_file);
need_sort := False;
if SectReq = 'NEWIN' then
begin
not_found := 0;
i := Pred(FileSize(nwin_file));
while (not brk) and (i >= 0) do
begin
Seek(nwin_file, i);
Read(nwin_file, nwin_rec);
with nwin_rec do
begin
if (status = public) and (ExistFile(Dirspec+'\'+name)) then
begin
write_rec;
need_sort := True;
end
else
begin
Inc(not_found);
if not_found > 100 then
i := 0;
end;
end;
i := Pred(i);
end;
Close(sort_file);
if need_sort then
not_found := TurboSort(SizeOf(sort_rec), @put_recs, @less_rec, @get_recs)
else
begin
Close(sort_file);
Erase(sort_file);
end;
if FileSize(nwin_file) = 0 then
WriteLn(Com, 'Newin List is empty.');
end
else
begin
SearchKey := SectReq;
key := SectReq;
FindKey(NewinArea, i, key);
if OK then
begin
repeat
Seek(nwin_file, i);
Read(nwin_file, nwin_rec);
if (nwin_rec.status = public) and ExistFile(dirspec+'\'+nwin_rec.name) then
begin
write_rec;
need_sort := True;
end;
NextKey(NewinArea, i, key);
until (not OK) or (key <> SearchKey) or brk;
Close(sort_file);
if need_sort then
not_found := TurboSort(SizeOf(sort_rec), @put_recs, @less_rec, @get_recs)
else
begin
{$I-}
Close(sort_file) {$I+};
if IoResult = 0 then
Erase(sort_file);
end;
end
else
begin
WriteLn(dir_file);
WriteLn(dir_file, 'No files listed for this section.');
WriteLn(dir_file);
end;
end;
end;
procedure Header;
var
This : SysmPtr;
rec : Integer;
begin
This := SysmBase;
while (This <> nil) and (This^.key <> 'G') do
This := This^.next;
if This^.key = 'G' then
begin
rec := Succ(This^.loc);
repeat
Seek(sysm_file, rec);
Read(sysm_file, sysm_rec);
Inc(rec);
if sysm_rec[1] <> ':' then
WriteLn(dir_file, sysm_rec);
until EoF(sysm_file) or (sysm_rec[1] = ':');
WriteLn(dir_file);
end;
end;
procedure Center(Str : StrStd);
{ Center string on print line }
begin
WriteLn(dir_file, ' ': ((user_rec.columns-Length(Str)) div 2), Str);
end;
begin { sys_dir }
Close(mesg_file);
abort := False;
SetSect(HomName);
WriteLn(Com);
Write(Com, 'Enter File Section name where SYSTEM.DIR will be written: ');
DestName := get_section_name(' ');
WriteLn(Com);
if ch <> ETX then
begin
WriteLn(Com);
WriteLn(Com, 'Building system directory...Please wait...');
KepDrv := SetDrv;
KepReq := SectReq;
KepName := SetName;
FindSect(DestName, TmpDrv, OK);
if not OK then
begin
TmpDrv := HomDrv;
TmpName := HomName;
end
else
begin
if DestName = 'SYSTEM' then
TmpName := HomName
else
begin
TmpName := TmpDrv;
if (Length(HomName) > 3) and (TmpDrv = HomDrv) then
begin
TmpName := TmpName+Copy(HomName, 4, Length(HomName));
TmpName := TmpName+'\';
end;
TmpName := TmpName+DestName;
end;
end;
Assign(dir_file, TmpName+'\'+'SYSTEM.DIR');
{$I-}
Rewrite(dir_file) {$I+} ;
OK := (IoResult = 0);
if OK then
begin
Header;
Center('Complete System Directory Listing');
Center('as of');
GetTAD(t);
Str := FormTAD(t);
Center(Str);
This := SectBase;
while (This <> nil) and (not brk) and (Online) do
begin
if This^.SectAccs <= val_acc then
begin
SectReq := This^.SectName;
SetDrv := This^.SectDrive;
SetName := This^.SectDrive+':\';
if (Length(HomName) > 3) and (SetName = HomDrv) then
begin
SetName := SetName+Copy(HomName, 4, Length(HomName));
SetName := SetName+'\';
end;
if Pos(':', This^.SectName) = 2 then
SetName := SetName+Copy(This^.SectName, 3, Length(This^.SectName))
else
SetName := SetName+This^.SectName;
write_list;
end; {section<access}
This := This^.next
end; {this<>nil}
Close(dir_file);
SetSect(HomName);
SectReq := KepReq;
SetDrv := KepDrv;
SetName := KepName;
ReadDir(DirEntries, DirSpace, DirBase)
end; {file opened ok}
WriteLn(Com);
end;
if ExistFile('SORT.TMP') then
Erase(sort_file);
Reset(mesg_file);
end;
procedure purge_files;
{ Purge various system files of extraneous records }
var
done : Boolean;
ch_sel : Char;
age, cur_date : Real;
t : tad_array;
procedure purge_log;
{ Purge the log file of all records }
begin
WriteLn(Com, 'Purging the LOG file...');
Seek(logr_file, 0);
Read(logr_file, logr_rec);
Close(logr_file);
Rewrite(logr_file);
Write(logr_file, logr_rec);
FlushAny(logr_file);
WriteLn(Com);
log(11, 'Log file');
end;
procedure purge_message;
{ Purge deleted messages }
const
col_width = 6;
var
i, col_count,
col_limit,
req_size : Integer;
size : Real;
nsum_file : file of summ_list;
nmsg_file : file of mesg_list;
begin
size := FileSize(summ_file)*80.0;
req_size := Trunc(size/1024.0);
if Frac(size/1024.0) > 0 then
req_size := req_size+2;
size := FileSize(mesg_file)*73.0;
req_size := req_size+Trunc(size/1024.0);
if Frac(size/1024.0) > 0 then
req_size := req_size+2;
if (diskfree(Ord(Upcase(HomDrv[1]))-64) div 1024) > req_size then
begin
col_limit := max(1, user_rec.columns div col_width);
WriteLn(Com, 'Purging the MESSAGE files...');
Assign(nsum_file, summ_name+'.$$$');
Assign(nmsg_file, mesg_name+'.$$$');
Rewrite(nsum_file);
Rewrite(nmsg_file);
Seek(summ_file, 0);
Read(summ_file, summ_rec); { Copy message counter to new file }
Write(nsum_file, summ_rec);
col_count := 0;
while not EoF(summ_file) do
with summ_rec do
begin
Read(summ_file, summ_rec);
age := cur_date-greg_to_jul(date[3], date[4], date[5]);
if ((status = deleted) or (age > unr_days) or ((status = Seen) and (age >
rea_days))) and
(num_prev <> 255) then
begin {delete message}
if (0 = col_count mod col_limit) then
WriteLn(Com);
Write(Com, num:col_width);
Inc(col_count)
end
else
begin {save message}
Seek(mesg_file, st_rec);
st_rec := FileSize(nmsg_file);
Write(nsum_file, summ_rec);
for i := 1 to size do
begin
Read(mesg_file, mesg_rec);
Write(nmsg_file, mesg_rec)
end
end
end;
Close(summ_file);
Close(mesg_file);
Close(nsum_file);
Close(nmsg_file);
Erase(summ_file);
Erase(mesg_file);
Rename(nsum_file, summ_name+ext);
Rename(nmsg_file, mesg_name+ext);
Reset(summ_file);
Reset(mesg_file);
mesg_build_index(AreaSet);
WriteLn(Com);
log(11, 'Msg file');
end
else
WriteLn(Com, 'Insufficient Disk space to purge MESSAGE files.');
end;
procedure purge_newin;
{ Purge deleted newin records }
var
new_nwin_file : file of nwin_list;
req_size : Integer;
size : Real;
i : LongInt;
begin
size := FileSize(nwin_file)*120.0;
req_size := Trunc(size/1024.0);
if Frac(size/1024.0) > 0 then
req_size := req_size+2;
if (diskfree(Ord(Upcase(HomDrv[1]))-64) div 1024) > req_size then
begin
WriteLn(Com, 'Purging the NEWIN file...');
Assign(new_nwin_file, nwin_name+'.$$$');
Rewrite(new_nwin_file);
Seek(nwin_file, 0);
repeat
{$I-}
Read(nwin_file, nwin_rec) {$I+} ;
if IoResult = 0 then
if nwin_rec.status <> deleted then
Write(new_nwin_file, nwin_rec)
until EoF(nwin_file);
Close(nwin_file);
Close(new_nwin_file);
Erase(nwin_file);
Rename(new_nwin_file, nwin_name+ext);
Reset(nwin_file);
Seek(nwin_file, 1);
if ExistFile(area_indx+ext) then
EraseIndex(NewinArea);
if ExistFile(name_indx+ext) then
EraseIndex(NewinName);
MakeIndex(NewinArea, area_indx+ext, 12, Duplicates);
MakeIndex(NewinName, name_indx+ext, 12, Duplicates);
WriteLn(Com, 'Indexing the NEWIN file...');
with nwin_rec do
begin
i := 1;
while (not EOF(nwin_file)) do
begin
Read(nwin_file, nwin_rec);
AddKey(NewinArea, i, sectn);
AddKey(NewinName, i, name);
Inc(i);
end;
end;
WriteLn(Com);
log(11, 'Newin');
end
else
WriteLn(Com, 'Insufficient disk space to purge NEWIN file.');
end;
procedure purge_user;
{ Purge outdated users }
var
i : Integer;
temp_user_loc : LongInt;
Str : StrTAD;
key : StrName;
temp_user_rec : user_list;
begin
WriteLn(Com, 'Purging the USER file...');
temp_user_loc := 1;
while temp_user_loc < FileLen(DatF) do
with temp_user_rec do
begin
GetRec(DatF, temp_user_loc, temp_user_rec);
age := cur_date-greg_to_jul(laston[3], laston[4], laston[5]);
if ((used = 0) and (not test_bit(temp_user_rec.Flags, 5)) and (((age > unv_days)
and
(access < val_acc)) or ((age > val_days) and (access >= val_acc)))) then
begin {purge the guy}
key := pad(ln, len_ln)+pad(fn, len_fn);
DeleteKey(IdxF, temp_user_loc, key);
if OK then
begin
DeleteRec(DatF, temp_user_loc);
Str := FormTAD(laston);
WriteLn(Com);
Write(Com, key, ' ', access, ' ', Str);
for i := 1 to Pred(FileSize(summ_file)) do
{ Delete messages pertaining to user }
begin
Seek(summ_file, i);
Read(summ_file, summ_rec);
if ((summ_rec.user_to = temp_user_loc) or (summ_rec.user_from =
temp_user_loc)) then
begin
WriteLn(Com);
mesg_delete;
end;
end;
{now clear newin file references}
Seek(nwin_file, 1);
repeat
{$I-}
Read(nwin_file, nwin_rec); {$I+}
if IoResult = 0 then
begin
if nwin_rec.user = temp_user_loc then
begin
nwin_rec.user := 0;
Seek(nwin_file, Pred(FilePos(nwin_file)));
Write(nwin_file, nwin_rec);
end;
end;
until EoF(nwin_file);
{now finally, the log file}
Seek(logr_file, 1);
repeat
{$I-}
Read(logr_file, logr_rec); {$I+}
if IoResult = 0 then
begin
if logr_rec.user = temp_user_loc then
begin
logr_rec.user := 0;
Seek(logr_file, Pred(FilePos(logr_file)));
Write(logr_file, logr_rec);
FlushAny(logr_file);
end;
end;
until EoF(logr_file);
end;
end;
Inc(temp_user_loc)
end;
WriteLn(Com);
log(11, 'Users');
end;
begin {PURGE FILES}
GetTAD(t);
SetSect(HomName);
cur_date := greg_to_jul(t[3], t[4], t[5]);
done := False;
repeat
st := prompt('File(s) to purge <A><L><M><N><U><Q><?> ', 80, 'ES?');
if Length(st) = 1 then
ch_sel := st[1]
else
ch_sel := '?';
case ch_sel of
'A' :
begin
if (not macro_in_progress) then
OK := ask('Do you want to purge ALL files', 'Y');
if macro_in_progress or OK then
begin
purge_log;
purge_newin;
purge_user;
purge_message;
done := True
end;
end;
'L' :
if macro_in_progress then
purge_log
else if ask('Do you want to purge the LOG file', 'Y') then
purge_log;
'M' :
if macro_in_progress then
purge_message
else if ask('Do you want to purge the MESSAGE files', 'Y') then
purge_message;
'N' :
if macro_in_progress then
purge_newin
else if ask('Do you want to purge the NEWIN file', 'Y') then
purge_newin;
'U' :
if macro_in_progress then
purge_user
else if ask('Do you want to purge the USER file', 'Y') then
purge_user;
'Q' :
done := True
else
WriteLn(Com, '<A>ll, <L>og, <M>essage, <N>ewin, <U>ser, <Q>uit');
end;
until (done) or (not Online);
end;
end. { of SYSOP2.PAS}